home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / alieneval.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  62.4 KB  |  1,951 lines
  1. ;;; -*- Package: ALIEN -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: alieneval.lisp,v 1.27 92/11/11 02:33:52 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains any the part of the Alien implementation that
  15. ;;; is not part of the compiler.
  16. ;;;
  17. (in-package "ALIEN")
  18. (use-package "EXT")
  19. (use-package "SYSTEM")
  20.  
  21. (export '(alien * array struct union enum function integer signed unsigned
  22.       boolean values single-float double-float system-area-pointer
  23.       def-alien-type def-alien-variable sap-alien
  24.       extern-alien with-alien slot deref addr cast alien-sap alien-size
  25.       alien-funcall def-alien-routine make-alien free-alien
  26.       null-alien))
  27.  
  28. (in-package "ALIEN-INTERNALS")
  29. (in-package "ALIEN")
  30.  
  31. (import '(alien alien-value alien-value-type parse-alien-type
  32.       unparse-alien-type alien-type-= alien-subtype-p alien-typep
  33.  
  34.       def-alien-type-class def-alien-type-translator def-alien-type-method
  35.       invoke-alien-type-method
  36.  
  37.       alien-type alien-type-p alien-type-bits alien-type-alignment
  38.       alien-integer-type alien-integer-type-p alien-integer-type-signed
  39.       alien-boolean-type alien-boolean-type-p
  40.       alien-enum-type alien-enum-type-p
  41.       alien-float-type alien-float-type-p
  42.       alien-single-float-type alien-single-float-type-p
  43.       alien-double-float-type alien-double-float-type-p
  44.       alien-pointer-type alien-pointer-type-p alien-pointer-type-to
  45.       make-alien-pointer-type
  46.       alien-array-type alien-array-type-p alien-array-type-element-type
  47.       alien-array-type-dimensions      
  48.       alien-record-type alien-record-type-p alien-record-type-fields
  49.       alien-record-field alien-record-field-p alien-record-field-name
  50.       alien-record-field-type alien-record-field-offset
  51.       alien-function-type alien-function-type-p make-alien-function-type
  52.       alien-function-type-result-type alien-function-type-arg-types
  53.       alien-values-type alien-values-type-p alien-values-type-values
  54.       *values-type-okay*
  55.  
  56.       %set-slot %slot-addr %set-deref %deref-addr
  57.  
  58.       %heap-alien %set-heap-alien %heap-alien-addr
  59.       heap-alien-info heap-alien-info-p heap-alien-info-type
  60.       heap-alien-info-sap-form
  61.  
  62.       local-alien %set-local-alien %local-alien-addr
  63.       local-alien-info local-alien-info-p local-alien-info-type
  64.       local-alien-info-force-to-memory-p
  65.       %local-alien-forced-to-memory-p
  66.       make-local-alien dispose-local-alien note-local-alien-type
  67.  
  68.       %cast %sap-alien align-offset
  69.  
  70.       extract-alien-value deposit-alien-value naturalize deport
  71.       compute-lisp-rep-type compute-alien-rep-type
  72.       compute-extract-lambda compute-deposit-lambda
  73.       compute-naturalize-lambda compute-deport-lambda)
  74.     "ALIEN-INTERNALS")
  75.  
  76. (export '(alien alien-value alien-value-type parse-alien-type
  77.       unparse-alien-type alien-type-= alien-subtype-p alien-typep
  78.  
  79.       def-alien-type-class def-alien-type-translator def-alien-type-method
  80.       invoke-alien-type-method
  81.  
  82.       alien-type alien-type-p alien-type-bits alien-type-alignment
  83.       alien-integer-type alien-integer-type-p alien-integer-type-signed
  84.       alien-boolean-type alien-boolean-type-p
  85.       alien-enum-type alien-enum-type-p
  86.       alien-float-type alien-float-type-p
  87.       alien-single-float-type alien-single-float-type-p
  88.       alien-double-float-type alien-double-float-type-p
  89.       alien-pointer-type alien-pointer-type-p alien-pointer-type-to
  90.       make-alien-pointer-type
  91.       alien-array-type alien-array-type-p alien-array-type-element-type
  92.       alien-array-type-dimensions      
  93.       alien-record-type alien-record-type-p alien-record-type-fields
  94.       alien-record-field alien-record-field-p alien-record-field-name
  95.       alien-record-field-type alien-record-field-offset
  96.       alien-function-type alien-function-type-p make-alien-function-type
  97.       alien-function-type-result-type alien-function-type-arg-types
  98.       alien-values-type alien-values-type-p alien-values-type-values
  99.       *values-type-okay*
  100.  
  101.       %set-slot %slot-addr %set-deref %deref-addr
  102.  
  103.       %heap-alien %set-heap-alien %heap-alien-addr
  104.       heap-alien-info heap-alien-info-p heap-alien-info-type
  105.       heap-alien-info-sap-form
  106.  
  107.       local-alien %set-local-alien %local-alien-addr
  108.       local-alien-info local-alien-info-p local-alien-info-type
  109.       local-alien-info-force-to-memory-p
  110.       %local-alien-forced-to-memory-p
  111.       make-local-alien dispose-local-alien note-local-alien-type
  112.  
  113.       %cast %sap-alien align-offset
  114.  
  115.       extract-alien-value deposit-alien-value naturalize deport
  116.       compute-lisp-rep-type compute-alien-rep-type
  117.       compute-extract-lambda compute-deposit-lambda
  118.       compute-naturalize-lambda compute-deport-lambda)
  119.     "ALIEN-INTERNALS")
  120.  
  121.  
  122.  
  123. ;;;; Utility functions.
  124.  
  125. (defun align-offset (offset alignment)
  126.   (let ((extra (rem offset alignment)))
  127.     (if (zerop extra) offset (+ offset (- alignment extra)))))
  128.  
  129. (defun guess-alignment (bits)
  130.   (cond ((null bits) nil)
  131.     ((> bits 16) 32)
  132.     ((> bits 8) 16)
  133.     ((> bits 1) 8)
  134.     (t 1)))
  135.  
  136.  
  137. ;;;; Alien-type-info stuff.
  138.  
  139. (eval-when (compile eval load)
  140.  
  141. (defstruct (alien-type-class
  142.         (:print-function %print-alien-type-class))
  143.   (name nil :type symbol)
  144.   (include nil :type (or null alien-type-class))
  145.   (unparse nil :type (or null function))
  146.   (type= nil :type (or null function))
  147.   (lisp-rep nil :type (or null function))
  148.   (alien-rep nil :type (or null function))
  149.   (extract-gen nil :type (or null function))
  150.   (deposit-gen nil :type (or null function))
  151.   (naturalize-gen nil :type (or null function))
  152.   (deport-gen nil :type (or null function))
  153.   ;; Cast?
  154.   (arg-tn nil :type (or null function))
  155.   (result-tn nil :type (or null function))
  156.   (subtypep nil :type (or null function)))
  157.  
  158. (defun %print-alien-type-class (type-class stream depth)
  159.   (declare (ignore depth))
  160.   (print-unreadable-object (type-class stream :type t)
  161.     (prin1 (alien-type-class-name type-class) stream)))
  162.  
  163. (defvar *alien-type-classes* (make-hash-table :test #'eq))
  164.  
  165. (defun alien-type-class-or-lose (name)
  166.   (or (gethash name *alien-type-classes*)
  167.       (error "No alien type class ~S" name)))
  168.  
  169. (defun create-alien-type-class-if-necessary (name include)
  170.   (let ((old (gethash name *alien-type-classes*))
  171.     (include (and include (alien-type-class-or-lose include))))
  172.     (if old
  173.     (setf (alien-type-class-include old) include)
  174.     (setf (gethash name *alien-type-classes*)
  175.           (make-alien-type-class :name name :include include)))))
  176.  
  177. (defconstant method-slot-alist
  178.   '((:unparse . alien-type-class-unparse)
  179.     (:type= . alien-type-class-type=)
  180.     (:subtypep . alien-type-class-subtypep)
  181.     (:lisp-rep . alien-type-class-lisp-rep)
  182.     (:alien-rep . alien-type-class-alien-rep)
  183.     (:extract-gen . alien-type-class-extract-gen)
  184.     (:deposit-gen . alien-type-class-deposit-gen)
  185.     (:naturalize-gen . alien-type-class-naturalize-gen)
  186.     (:deport-gen . alien-type-class-deport-gen)
  187.     ;; Cast?
  188.     (:arg-tn . alien-type-class-arg-tn)
  189.     (:result-tn . alien-type-class-result-tn)))
  190.  
  191. (defun method-slot (method)
  192.   (cdr (or (assoc method method-slot-alist)
  193.        (error "No method ~S" method))))
  194.  
  195. ); eval-when
  196.  
  197.  
  198. (defmacro def-alien-type-class ((name &key include) &rest slots)
  199.   (let ((defstruct-name
  200.      (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
  201.     (multiple-value-bind
  202.     (include include-defstruct overrides)
  203.     (etypecase include
  204.       (null
  205.        (values nil 'alien-type nil))
  206.       (symbol
  207.        (values
  208.         include
  209.         (intern (concatenate 'string
  210.                  "ALIEN-" (symbol-name include) "-TYPE"))
  211.         nil))
  212.       (list
  213.        (values
  214.         (car include)
  215.         (intern (concatenate 'string
  216.                  "ALIEN-" (symbol-name (car include)) "-TYPE"))
  217.         (cdr include))))
  218.       `(progn
  219.      (eval-when (compile load eval)
  220.        (create-alien-type-class-if-necessary ',name ',(or include 'root)))
  221.      (defstruct (,defstruct-name
  222.             (:include ,include-defstruct
  223.                   (:class ',name)
  224.                   ,@overrides))
  225.        ,@slots)))))
  226.  
  227. (defmacro def-alien-type-method ((class method) lambda-list &rest body)
  228.   (let ((defun-name (intern (concatenate 'string
  229.                      (symbol-name class)
  230.                      "-"
  231.                      (symbol-name method)
  232.                      "-METHOD"))))
  233.     `(progn
  234.        (defun ,defun-name ,lambda-list
  235.      ,@body)
  236.        (setf (,(method-slot method) (alien-type-class-or-lose ',class))
  237.          #',defun-name))))
  238.  
  239. (defmacro invoke-alien-type-method (method type &rest args)
  240.   (let ((slot (method-slot method)))
  241.     (once-only ((type type))
  242.       `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
  243.                 (alien-type-class-include class)))
  244.             ((null class)
  245.              (error "Method ~S not defined for ~S"
  246.                 ',method (alien-type-class ,type)))
  247.           (let ((fn (,slot class)))
  248.             (when fn
  249.               (return fn))))
  250.         ,type ,@args))))
  251.  
  252.  
  253.  
  254. ;;;; Alien-type defstruct.
  255.  
  256. (eval-when (compile load eval)
  257.   (create-alien-type-class-if-necessary 'root nil))
  258.  
  259. (defstruct (alien-type
  260.         (:print-function %print-alien-type)
  261.         (:make-load-form-fun :just-dump-it-normally))
  262.   (class 'root :type symbol)
  263.   (bits nil :type (or null unsigned-byte))
  264.   (alignment (guess-alignment bits) :type (or null unsigned-byte)))
  265.  
  266. (defun %print-alien-type (type stream depth)
  267.   (declare (ignore depth))
  268.   (print-unreadable-object (type stream :type t)
  269.     (prin1 (unparse-alien-type type) stream)))
  270.  
  271.  
  272. ;;;; Type parsing and unparsing.
  273.  
  274. (defvar *auxiliary-type-definitions* nil)
  275. (defvar *new-auxiliary-types*)
  276.  
  277. ;;; WITH-AUXILIARY-ALIEN-TYPES -- internal.
  278. ;;;
  279. ;;; Process stuff in a new scope.
  280. ;;;
  281. (defmacro with-auxiliary-alien-types (&body body)
  282.   `(let ((*auxiliary-type-definitions*
  283.       (if (boundp '*new-auxiliary-types*)
  284.           (append *new-auxiliary-types* *auxiliary-type-definitions*)
  285.           *auxiliary-type-definitions*))
  286.      (*new-auxiliary-types* nil))
  287.      ,@body))
  288.  
  289. ;;; PARSE-ALIEN-TYPE -- public
  290. ;;;
  291. (defun parse-alien-type (type)
  292.   "Parse the list structure TYPE as an alien type specifier and return
  293.    the resultant alien-type structure."
  294.   (if (boundp '*new-auxiliary-types*)
  295.       (%parse-alien-type type)
  296.       (let ((*new-auxiliary-types* nil))
  297.     (%parse-alien-type type))))
  298.  
  299. (defun %parse-alien-type (type)
  300.   (if (consp type)
  301.       (let ((translator (info alien-type translator (car type))))
  302.     (unless translator
  303.       (error "Unknown alien type: ~S" type))
  304.     (funcall translator type))
  305.       (case (info alien-type kind type)
  306.     (:primitive
  307.      (let ((translator (info alien-type translator type)))
  308.        (unless translator
  309.          (error "No translator for primitive alien type ~S?" type))
  310.        (funcall translator (list type))))
  311.     (:defined
  312.      (or (info alien-type definition type)
  313.          (error "Definition missing for alien type ~S?" type)))
  314.     (:unknown
  315.      (error "Unknown alien type: ~S" type)))))
  316.  
  317. (defun auxiliary-alien-type (kind name)
  318.   (flet ((aux-defn-matches (x)
  319.        (and (eq (first x) kind) (eq (second x) name))))
  320.     (let ((in-auxiliaries
  321.        (or (find-if #'aux-defn-matches *new-auxiliary-types*)
  322.            (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
  323.       (if in-auxiliaries
  324.       (values (third in-auxiliaries) t)
  325.       (ecase kind
  326.         (:struct
  327.          (info alien-type struct name))
  328.         (:union
  329.          (info alien-type union name))
  330.         (:enum
  331.          (info alien-type enum name)))))))
  332.  
  333. (defun %set-auxiliary-alien-type (kind name defn)
  334.   (flet ((aux-defn-matches (x)
  335.        (and (eq (first x) kind) (eq (second x) name))))
  336.     (when (find-if #'aux-defn-matches *new-auxiliary-types*)
  337.       (error "Attempt to multiple define ~A ~S." kind name))
  338.     (when (find-if #'aux-defn-matches *auxiliary-type-definitions*)
  339.       (error "Attempt to shadow definition of ~A ~S." kind name)))
  340.   (push (list kind name defn) *new-auxiliary-types*)
  341.   defn)
  342.  
  343. (defsetf auxiliary-alien-type %set-auxiliary-alien-type)
  344.  
  345. (defun verify-local-auxiliaries-okay ()
  346.   (dolist (info *new-auxiliary-types*)
  347.     (destructuring-bind (kind name defn) info
  348.       (declare (ignore defn))
  349.       (when (ecase kind
  350.           (:struct
  351.            (info alien-type struct name))
  352.           (:union
  353.            (info alien-type union name))
  354.           (:enum
  355.            (info alien-type enum name)))
  356.     (error "Attempt to shadow definition of ~A ~S." kind name)))))
  357.  
  358. ;;; *record-type-already-unparsed* -- internal
  359. ;;;
  360. ;;; Holds the list of record types that have already been unparsed.  This is
  361. ;;; used to keep from outputing the slots again if the same structure shows
  362. ;;; up twice.
  363. ;;; 
  364. (defvar *record-types-already-unparsed*)
  365.  
  366. ;;; UNPARSE-ALIEN-TYPE -- public.
  367. ;;; 
  368. (defun unparse-alien-type (type)
  369.   "Convert the alien-type structure TYPE back into a list specification of
  370.    the type."
  371.   (declare (type alien-type type))
  372.   (let ((*record-types-already-unparsed* nil))
  373.     (%unparse-alien-type type)))
  374.  
  375. ;;; %UNPARSE-ALIEN-TYPE -- internal.
  376. ;;;
  377. ;;; Does all the work of UNPARSE-ALIEN-TYPE.  It's seperate because we need
  378. ;;; to recurse inside the binding of *record-types-already-unparsed*.
  379. ;;; 
  380. (defun %unparse-alien-type (type)
  381.   (invoke-alien-type-method :unparse type))
  382.  
  383.  
  384.  
  385.  
  386. ;;;; Alien type defining stuff.
  387.  
  388. (defmacro def-alien-type-translator (name lambda-list &body body)
  389.   (let ((whole (gensym))
  390.     (defun-name (intern (concatenate 'string
  391.                      "ALIEN-"
  392.                      (symbol-name name)
  393.                      "-TYPE-TRANSLATOR"))))
  394.     (multiple-value-bind
  395.     (body decls docs)
  396.     (lisp::parse-defmacro lambda-list whole body name
  397.                   'def-alien-type-translator)
  398.       `(progn
  399.      (defun ,defun-name (,whole)
  400.        ,decls
  401.        (block ,name
  402.          ,body))
  403.      (%def-alien-type-translator ',name #',defun-name ,docs)))))
  404.  
  405. (defun %def-alien-type-translator (name translator docs)
  406.   (declare (ignore docs))
  407.   (setf (info alien-type kind name) :primitive)
  408.   (setf (info alien-type translator name) translator)
  409.   (clear-info alien-type definition name)
  410.   #+nil
  411.   (setf (documentation name 'alien-type) docs)
  412.   name)
  413.  
  414.  
  415. (defmacro def-alien-type (name type)
  416.   "Define the alien type NAME to be equivalent to TYPE.  Name may be NIL for
  417.    STRUCT and UNION types, in which case the name is taken from the type
  418.    specifier."
  419.   (with-auxiliary-alien-types
  420.     (let ((alien-type (parse-alien-type type)))
  421.       `(eval-when (compile load eval)
  422.      ,@(when *new-auxiliary-types*
  423.          `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
  424.      ,@(when name
  425.          `((%def-alien-type ',name ',alien-type)))))))
  426.  
  427. (defun %def-auxiliary-alien-types (types)
  428.   (dolist (info types)
  429.     (destructuring-bind (kind name defn) info
  430.       (macrolet ((frob (kind)
  431.            `(let ((old (info alien-type ,kind name)))
  432.               (unless (or (null old) (alien-type-= old defn))
  433.             (warn "Redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
  434.                   kind name defn old))
  435.               (setf (info alien-type ,kind name) defn))))
  436.     (ecase kind
  437.       (:struct (frob struct))
  438.       (:union (frob union))
  439.       (:enum (frob enum)))))))
  440.  
  441. (defun %def-alien-type (name new)
  442.   (ecase (info alien-type kind name)
  443.     (:primitive
  444.      (error "~S is a built-in alien type." name))
  445.     (:defined
  446.      (let ((old (info alien-type definition name)))
  447.        (unless (or (null old) (alien-type-= new old))
  448.      (warn "Redefining ~S to be:~%  ~S,~%was~%  ~S" name
  449.            (unparse-alien-type new) (unparse-alien-type old)))))
  450.     (:unknown))
  451.   (setf (info alien-type definition name) new)
  452.   (setf (info alien-type kind name) :defined)
  453.   name)
  454.  
  455.  
  456.  
  457. ;;;; Interfaces to the different methods
  458.  
  459. (defun alien-type-= (type1 type2)
  460.   "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
  461.   (or (eq type1 type2)
  462.       (and (eq (alien-type-class type1)
  463.            (alien-type-class type2))
  464.        (invoke-alien-type-method :type= type1 type2))))
  465.  
  466. (defun alien-subtype-p (type1 type2)
  467.   "Return T iff the alien type TYPE1 is a subtype of TYPE2.  Currently, the
  468.    only supported subtype relationships are is that any pointer type is a
  469.    subtype of (* t), and any array type first dimension will match 
  470.    (array <eltype> nil ...).  Otherwise, the two types have to be
  471.    ALIEN-TYPE-=."
  472.   (or (eq type1 type2)
  473.       (invoke-alien-type-method :subtypep type1 type2)))
  474.  
  475. (defun alien-typep (object type)
  476.   "Return T iff OBJECT is an alien of type TYPE."
  477.   (let ((lisp-rep-type (compute-lisp-rep-type type)))
  478.     (if lisp-rep-type
  479.     (typep object lisp-rep-type)
  480.     (and (alien-value-p object)
  481.          (alien-subtype-p (alien-value-type object) type)))))
  482.  
  483.  
  484. (defun compute-naturalize-lambda (type)
  485.   `(lambda (alien ignore)
  486.      (declare (ignore ignore))
  487.      ,(invoke-alien-type-method :naturalize-gen type 'alien)))
  488.  
  489. (defun compute-deport-lambda (type)
  490.   (declare (type alien-type type))
  491.   (multiple-value-bind
  492.       (form value-type)
  493.       (invoke-alien-type-method :deport-gen type 'value)
  494.     `(lambda (value ignore)
  495.        (declare (type ,(or value-type
  496.                (compute-lisp-rep-type type)
  497.                `(alien ,type))
  498.               value)
  499.         (ignore ignore))
  500.        ,form)))
  501.  
  502. (defun compute-extract-lambda (type)
  503.   `(lambda (sap offset ignore)
  504.      (declare (type system-area-pointer sap)
  505.           (type unsigned-byte offset)
  506.           (ignore ignore))
  507.      (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
  508.          ',type)))
  509.  
  510. (defun compute-deposit-lambda (type)
  511.   (declare (type alien-type type))
  512.   `(lambda (sap offset ignore value)
  513.      (declare (type system-area-pointer sap)
  514.           (type unsigned-byte offset)
  515.           (ignore ignore))
  516.      (let ((value (deport value ',type)))
  517.        ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
  518.        ;; Note: the reason we don't just return the pre-deported value
  519.        ;; is because that would inhibit any (deport (naturalize ...))
  520.        ;; optimizations that might have otherwise happen.  Re-naturalizing
  521.        ;; the value might cause extra consing, but is flushable, so probably
  522.        ;; results in better code.
  523.        (naturalize value ',type))))
  524.  
  525. (defun compute-lisp-rep-type (type)
  526.   (invoke-alien-type-method :lisp-rep type))
  527.  
  528. (defun compute-alien-rep-type (type)
  529.   (invoke-alien-type-method :alien-rep type))
  530.  
  531.  
  532.  
  533.  
  534.  
  535. ;;;; Default methods.
  536.  
  537. (def-alien-type-method (root :unparse) (type)
  538.   `(!!unknown-alien-type!! ,(type-of type)))
  539.  
  540. (def-alien-type-method (root :type=) (type1 type2)
  541.   (declare (ignore type1 type2))
  542.   t)
  543.  
  544. (def-alien-type-method (root :subtypep) (type1 type2)
  545.   (alien-type-= type1 type2))
  546.  
  547. (def-alien-type-method (root :lisp-rep) (type)
  548.   (declare (ignore type))
  549.   nil)
  550.  
  551. (def-alien-type-method (root :alien-rep) (type)
  552.   (declare (ignore type))
  553.   '*)
  554.  
  555. (def-alien-type-method (root :naturalize-gen) (type alien)
  556.   (declare (ignore alien))
  557.   (error "Cannot represent ~S typed aliens." type))
  558.  
  559. (def-alien-type-method (root :deport-gen) (type object)
  560.   (declare (ignore object))
  561.   (error "Cannot represent ~S typed aliens." type))
  562.  
  563. (def-alien-type-method (root :extract-gen) (type sap offset)
  564.   (declare (ignore sap offset))
  565.   (error "Cannot represent ~S typed aliens." type))
  566.  
  567. (def-alien-type-method (root :deposit-gen) (type sap offset value)
  568.   `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
  569.  
  570. (def-alien-type-method (root :arg-tn) (type state)
  571.   (declare (ignore state))
  572.   (error "Cannot pass aliens of type ~S as arguments to call-out"
  573.      (unparse-alien-type type)))
  574.  
  575. (def-alien-type-method (root :result-tn) (type state)
  576.   (declare (ignore state))
  577.   (error "Cannot return aliens of type ~S from call-out"
  578.      (unparse-alien-type type)))
  579.  
  580.  
  581. ;;;; The INTEGER type.
  582.  
  583. (def-alien-type-class (integer)
  584.   (signed t :type (member t nil)))
  585.  
  586. (def-alien-type-translator signed (&optional (bits vm:word-bits))
  587.   (make-alien-integer-type :bits bits))
  588.  
  589. (def-alien-type-translator integer (&optional (bits vm:word-bits))
  590.   (make-alien-integer-type :bits bits))
  591.  
  592. (def-alien-type-translator unsigned (&optional (bits vm:word-bits))
  593.   (make-alien-integer-type :bits bits :signed nil))
  594.  
  595. (def-alien-type-method (integer :unparse) (type)
  596.   (list (if (alien-integer-type-signed type) 'signed 'unsigned)
  597.     (alien-integer-type-bits type)))
  598.  
  599. (def-alien-type-method (integer :type=) (type1 type2)
  600.   (and (eq (alien-integer-type-signed type1)
  601.        (alien-integer-type-signed type2))
  602.        (= (alien-integer-type-bits type1)
  603.       (alien-integer-type-bits type2))))
  604.  
  605. (def-alien-type-method (integer :lisp-rep) (type)
  606.   (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
  607.     (alien-integer-type-bits type)))
  608.  
  609. (def-alien-type-method (integer :alien-rep) (type)
  610.   (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
  611.     (alien-integer-type-bits type)))
  612.  
  613. (def-alien-type-method (integer :naturalize-gen) (type alien)
  614.   (declare (ignore type))
  615.   alien)
  616.  
  617. (def-alien-type-method (integer :deport-gen) (type value)
  618.   (declare (ignore type))
  619.   value)
  620.  
  621. (def-alien-type-method (integer :extract-gen) (type sap offset)
  622.   (declare (type alien-integer-type type))
  623.   (let ((ref-fun
  624.      (if (alien-integer-type-signed type)
  625.       (case (alien-integer-type-bits type)
  626.         (8 'signed-sap-ref-8)
  627.         (16 'signed-sap-ref-16)
  628.         (32 'signed-sap-ref-32))
  629.       (case (alien-integer-type-bits type)
  630.         (8 'sap-ref-8)
  631.         (16 'sap-ref-16)
  632.         (32 'sap-ref-32)))))
  633.     (if ref-fun
  634.     `(,ref-fun ,sap (/ ,offset vm:byte-bits))
  635.     (error "Cannot extract ~D bit integers."
  636.            (alien-integer-type-bits type)))))
  637.  
  638.  
  639.  
  640. ;;;; The BOOLEAN type.
  641.  
  642. (def-alien-type-class (boolean :include integer))
  643.  
  644. (def-alien-type-translator boolean (&optional (bits vm:word-bits))
  645.   (make-alien-boolean-type :bits bits :signed nil))
  646.  
  647. (def-alien-type-method (boolean :unparse) (type)
  648.   `(boolean ,(alien-boolean-type-bits type)))
  649.  
  650. (def-alien-type-method (boolean :lisp-rep) (type)
  651.   (declare (ignore type))
  652.   `(member t nil))
  653.  
  654. (def-alien-type-method (boolean :naturalize-gen) (type alien)
  655.   (declare (ignore type))
  656.   `(not (zerop ,alien)))
  657.  
  658. (def-alien-type-method (boolean :deport-gen) (value type)
  659.   (declare (ignore type))
  660.   `(if ,value 1 0))
  661.  
  662.  
  663. ;;;; The ENUM type.
  664.  
  665. (def-alien-type-class (enum :include (integer (:bits 32)))
  666.   name        ; name of this enum (if any)
  667.   from        ; alist from keywords to integers.
  668.   to        ; alist or vector from integers to keywords.
  669.   kind        ; Kind of from mapping, :vector or :alist.
  670.   offset)    ; Offset to add to value for :vector from mapping.
  671.  
  672. (def-alien-type-translator enum (&whole type name &rest mappings)
  673.   (cond (mappings
  674.      (let ((result (parse-enum name mappings)))
  675.        (when name
  676.          (multiple-value-bind
  677.          (old old-p)
  678.          (auxiliary-alien-type :enum name)
  679.            (when old-p
  680.          (unless (alien-type-= result old)
  681.            (warn "Redefining alien enum ~S" name))))
  682.          (setf (auxiliary-alien-type :enum name) result))
  683.        result))
  684.     (name
  685.      (multiple-value-bind
  686.          (result found)
  687.          (auxiliary-alien-type :enum name)
  688.        (unless found
  689.          (error "Unknown enum type: ~S" name))
  690.        result))
  691.     (t
  692.      (error "Empty enum type: ~S" type))))
  693.  
  694. (defun parse-enum (name elements)
  695.   (when (null elements)
  696.     (error "An anumeration must contain at least one element."))
  697.   (let ((min nil)
  698.     (max nil)
  699.     (from-alist ())
  700.     (prev -1))
  701.     (declare (list from-alist))
  702.     (dolist (el elements)
  703.       (multiple-value-bind
  704.       (sym val)
  705.       (if (listp el)
  706.           (values (first el) (second el))
  707.           (values el (1+ prev)))
  708.     (setf prev val)
  709.     (unless (keywordp sym)
  710.       (error "Enumeration element ~S is not a keyword." sym))
  711.     (unless (integerp val)
  712.       (error "Element value ~S is not an integer." val))
  713.     (unless (and max (> max val)) (setq max val))
  714.     (unless (and min (< min val)) (setq min val))
  715.     (when (rassoc val from-alist)
  716.       (error "Element value ~S used more than once." val))
  717.     (when (assoc sym from-alist :test #'eq)
  718.       (error "Enumeration element ~S used more than once." sym))
  719.     (push (cons sym val) from-alist)))
  720.     (let* ((signed (minusp min))
  721.        (min-bits (if signed
  722.              (1+ (max (integer-length min)
  723.                   (integer-length max)))
  724.              (integer-length max))))
  725.       (when (> min-bits 32)
  726.     (error "Can't represent enums needing more than 32 bits."))
  727.       (setf from-alist (sort from-alist #'< :key #'cdr))
  728.       (cond
  729.        ;;
  730.        ;; If range is at least 20% dense, use vector mapping.  Crossover
  731.        ;; point solely on basis of space would be 25%.  Vector mapping
  732.        ;; is always faster, so give the benefit of the doubt.
  733.        ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
  734.     ;;
  735.     ;; If offset is small and ignorable, ignore it to save time.
  736.     (when (< 0 min 10) (setq min 0))
  737.     (let ((to (make-array (1+ (- max min)))))
  738.       (dolist (el from-alist)
  739.         (setf (svref to (- (cdr el) min)) (car el)))
  740.       (make-alien-enum-type :name name :signed signed
  741.                 :from from-alist :to to :kind
  742.                 :vector :offset (- min))))
  743.        (t
  744.     (make-alien-enum-type :name name :signed signed
  745.                   :from from-alist
  746.                   :to (mapcar #'(lambda (x) (cons (cdr x) (car x)))
  747.                       from-alist)
  748.                   :kind :alist))))))
  749.  
  750. (def-alien-type-method (enum :unparse) (type)
  751.   `(enum ,(alien-enum-type-name type)
  752.      ,@(let ((prev -1))
  753.          (mapcar #'(lambda (mapping)
  754.              (let ((sym (car mapping))
  755.                    (value (cdr mapping)))
  756.                (prog1
  757.                    (if (= (1+ prev) value)
  758.                    sym
  759.                    `(,sym ,value))
  760.                  (setf prev value))))
  761.              (alien-enum-type-from type)))))
  762.  
  763. (def-alien-type-method (enum :type=) (type1 type2)
  764.   (and (eq (alien-enum-type-name type1)
  765.        (alien-enum-type-name type2))
  766.        (equal (alien-enum-type-from type1)
  767.           (alien-enum-type-from type2))))
  768.  
  769. (def-alien-type-method (enum :lisp-rep) (type)
  770.   `(member ,@(mapcar #'car (alien-enum-type-from type))))
  771.  
  772. (def-alien-type-method (enum :naturalize-gen) (type alien)
  773.   (ecase (alien-enum-type-kind type)
  774.     (:vector
  775.      `(svref ',(alien-enum-type-to type)
  776.          (+ ,alien ,(alien-enum-type-offset type))))
  777.     (:alist
  778.      `(ecase ,alien
  779.     ,@(mapcar #'(lambda (mapping)
  780.               `(,(car mapping) ,(cdr mapping)))
  781.           (alien-enum-type-to type))))))
  782.  
  783. (def-alien-type-method (enum :deport-gen) (type value)
  784.   `(ecase ,value
  785.      ,@(mapcar #'(lambda (mapping)
  786.            `(,(car mapping) ,(cdr mapping)))
  787.            (alien-enum-type-from type))))
  788.  
  789.  
  790.  
  791. ;;;; the FLOAT types.
  792.  
  793. (def-alien-type-class (float)
  794.   (type (required-argument) :type symbol))
  795.  
  796. (def-alien-type-method (float :unparse) (type)
  797.   (alien-float-type-type type))
  798.  
  799. (def-alien-type-method (float :lisp-rep) (type)
  800.   (alien-float-type-type type))
  801.  
  802. (def-alien-type-method (float :alien-rep) (type)
  803.   (alien-float-type-type type))
  804.  
  805. (def-alien-type-method (float :naturalize-gen) (type alien)
  806.   (declare (ignore type))
  807.   alien)
  808.  
  809. (def-alien-type-method (float :deport-gen) (type value)
  810.   (declare (ignore type))
  811.   value)
  812.  
  813.  
  814. (def-alien-type-class (single-float :include (float (:bits 32))))
  815.  
  816. (def-alien-type-translator single-float ()
  817.   (make-alien-single-float-type :type 'single-float))
  818.  
  819. (def-alien-type-method (single-float :extract-gen) (type sap offset)
  820.   (declare (ignore type))
  821.   `(sap-ref-single ,sap (/ ,offset vm:byte-bits)))
  822.  
  823.  
  824. (def-alien-type-class (double-float :include (float (:bits 64))))
  825.  
  826. (def-alien-type-translator double-float ()
  827.   (make-alien-double-float-type :type 'double-float))
  828.  
  829. (def-alien-type-method (double-float :extract-gen) (type sap offset)
  830.   (declare (ignore type))
  831.   `(sap-ref-double ,sap (/ ,offset vm:byte-bits)))
  832.  
  833.  
  834.  
  835. ;;;; The SAP type
  836.  
  837. (def-alien-type-class (system-area-pointer))
  838.  
  839. (def-alien-type-translator system-area-pointer ()
  840.   (make-alien-system-area-pointer-type :bits vm:word-bits))
  841.  
  842. (def-alien-type-method (system-area-pointer :unparse) (type)
  843.   (declare (ignore type))
  844.   'system-area-pointer)
  845.  
  846. (def-alien-type-method (system-area-pointer :lisp-rep) (type)
  847.   (declare (ignore type))
  848.   'system-area-pointer)
  849.  
  850. (def-alien-type-method (system-area-pointer :alien-rep) (type)
  851.   (declare (ignore type))
  852.   'system-area-pointer)
  853.  
  854. (def-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
  855.   (declare (ignore type))
  856.   alien)
  857.  
  858. (def-alien-type-method (system-area-pointer :deport-gen) (type object)
  859.   (declare (ignore type))
  860.   object)
  861.  
  862. (def-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
  863.   (declare (ignore type))
  864.   `(sap-ref-sap ,sap (/ ,offset vm:byte-bits)))
  865.  
  866.  
  867. ;;;; the ALIEN-VALUE type.
  868.  
  869. (def-alien-type-class (alien-value :include system-area-pointer))
  870.  
  871. (def-alien-type-method (alien-value :lisp-rep) (type)
  872.   (declare (ignore type))
  873.   nil)
  874.  
  875. (def-alien-type-method (alien-value :naturalize-gen) (type alien)
  876.   `(%sap-alien ,alien ',type))
  877.  
  878. (def-alien-type-method (alien-value :deport-gen) (type value)
  879.   (declare (ignore type))
  880.   `(alien-sap ,value))
  881.  
  882.  
  883.  
  884. ;;;; The POINTER type.
  885.  
  886. (def-alien-type-class (pointer :include (alien-value (:bits vm:word-bits)))
  887.   (to nil :type (or alien-type null)))
  888.  
  889. (def-alien-type-translator * (to)
  890.   (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to))))
  891.  
  892. (def-alien-type-method (pointer :unparse) (type)
  893.   (let ((to (alien-pointer-type-to type)))
  894.     `(* ,(if to
  895.          (%unparse-alien-type to)
  896.          t))))
  897.  
  898. (def-alien-type-method (pointer :type=) (type1 type2)
  899.   (let ((to1 (alien-pointer-type-to type1))
  900.     (to2 (alien-pointer-type-to type2)))
  901.     (if to1
  902.     (if to2
  903.         (alien-type-= to1 to2)
  904.         nil)
  905.     (null to2))))
  906.  
  907. (def-alien-type-method (pointer :subtypep) (type1 type2)
  908.   (and (alien-pointer-type-p type2)
  909.        (let ((to1 (alien-pointer-type-to type1))
  910.          (to2 (alien-pointer-type-to type2)))
  911.      (if to1
  912.          (if to2
  913.          (alien-subtype-p to1 to2)
  914.          t)
  915.          nil))))
  916.  
  917. (def-alien-type-method (pointer :deport-gen) (type value)
  918.   (values
  919.    `(etypecase ,value
  920.       (null
  921.        (int-sap 0))
  922.       (system-area-pointer
  923.        ,value)
  924.       ((alien ,type)
  925.        (alien-sap ,value)))
  926.    `(or null system-area-pointer (alien ,type))))
  927.  
  928.  
  929. ;;;; The MEM-BLOCK type.
  930.  
  931. (def-alien-type-class (mem-block :include alien-value))
  932.  
  933. (def-alien-type-method (mem-block :extract-gen) (type sap offset)
  934.   (declare (ignore type))
  935.   `(sap+ ,sap (/ ,offset vm:byte-bits)))
  936.  
  937. (def-alien-type-method (mem-block :deposit-gen) (type sap offset value)
  938.   (let ((bits (alien-mem-block-type-bits type)))
  939.     (unless bits
  940.       (error "Cannot deposit aliens of type ~S (unknown size)." type))
  941.     `(kernel:system-area-copy ,value 0 ,sap ,offset ',bits)))
  942.  
  943.  
  944. ;;;; The ARRAY type.
  945.  
  946. (def-alien-type-class (array :include mem-block)
  947.   (element-type (required-argument) :type alien-type)
  948.   (dimensions (required-argument) :type list))
  949.  
  950. (def-alien-type-translator array (ele-type &rest dims)
  951.   (when dims
  952.     (unless (typep (first dims) '(or kernel:index null))
  953.       (error "First dimension is not a non-negative fixnum or NIL: ~S"
  954.          (first dims)))
  955.     (let ((loser (find-if-not #'(lambda (x) (typep x 'kernel:index))
  956.                   (rest dims))))
  957.       (when loser
  958.     (error "Dimension is not a non-negative fixnum: ~S" loser))))
  959.     
  960.   (let ((type (parse-alien-type ele-type)))
  961.     (make-alien-array-type
  962.      :element-type type
  963.      :dimensions dims
  964.      :alignment (alien-type-alignment type)
  965.      :bits (if (and (alien-type-bits type)
  966.             (every #'integerp dims))
  967.            (* (align-offset (alien-type-bits type)
  968.                 (alien-type-alignment type))
  969.           (reduce #'* dims))))))
  970.  
  971. (def-alien-type-method (array :unparse) (type)
  972.   `(array ,(%unparse-alien-type (alien-array-type-element-type type))
  973.       ,@(alien-array-type-dimensions type)))
  974.  
  975. (def-alien-type-method (array :type=) (type1 type2)
  976.   (and (equal (alien-array-type-dimensions type1)
  977.           (alien-array-type-dimensions type2))
  978.        (alien-type-= (alien-array-type-element-type type1)
  979.              (alien-array-type-element-type type2))))
  980.  
  981. (def-alien-type-method (array :subtypep) (type1 type2)
  982.   (and (alien-array-type-p type2)
  983.        (let ((dim1 (alien-array-type-dimensions type1))
  984.          (dim2 (alien-array-type-dimensions type2)))
  985.      (and (= (length dim1) (length dim2))
  986.           (or (and dim2
  987.                (null (car dim2))
  988.                (equal (cdr dim1) (cdr dim2)))
  989.           (equal dim1 dim2))
  990.           (alien-subtype-p (alien-array-type-element-type type1)
  991.                    (alien-array-type-element-type type2))))))
  992.  
  993.  
  994. ;;;; The RECORD type.
  995.  
  996. (defstruct (alien-record-field
  997.         (:print-function %print-alien-field)
  998.         (:make-load-form-fun :just-dump-it-normally))
  999.   (name (required-argument) :type symbol)
  1000.   (type (required-argument) :type alien-type)
  1001.   (bits nil :type (or unsigned-byte null))
  1002.   (offset 0 :type unsigned-byte))
  1003.  
  1004. (defun %print-alien-field (field stream depth)
  1005.   (declare (ignore depth))
  1006.   (print-unreadable-object (field stream :type t)
  1007.     (funcall (formatter "~S ~S~@[:~D~]")
  1008.          stream
  1009.          (alien-record-field-type field)
  1010.          (alien-record-field-name field)
  1011.          (alien-record-field-bits field))))
  1012.  
  1013. (def-alien-type-class (record :include mem-block)
  1014.   (kind :struct :type (member :struct :union))
  1015.   (name nil :type (or symbol null))
  1016.   (fields nil :type list))
  1017.  
  1018. (def-alien-type-translator struct (name &rest fields)
  1019.   (parse-alien-record-type :struct name fields))
  1020.  
  1021. (def-alien-type-translator union (name &rest fields)
  1022.   (parse-alien-record-type :union name fields))
  1023.  
  1024. (defun parse-alien-record-type (kind name fields)
  1025.   (if fields
  1026.       (let* ((old (and name (auxiliary-alien-type kind name)))
  1027.          (result (if (or (null old)
  1028.                  (alien-record-type-fields old))
  1029.              (make-alien-record-type :name name :kind kind)
  1030.              old)))
  1031.     (when (and name (not (eq old result)))
  1032.       (setf (auxiliary-alien-type kind name) result))
  1033.     (parse-alien-record-fields result fields)
  1034.     result)
  1035.       (if name
  1036.       (or (auxiliary-alien-type kind name)
  1037.           (setf (auxiliary-alien-type kind name)
  1038.             (make-alien-record-type :name name :kind kind)))
  1039.       (make-alien-record-type :kind kind))))
  1040.  
  1041. ;;; PARSE-ALIEN-RECORD-FIELDS -- internal
  1042. ;;;
  1043. ;;; Used by parse-alien-type to parse the fields of struct and union
  1044. ;;; types.  RESULT holds the record type we are paring the fields of,
  1045. ;;; and FIELDS is the list of field specifications.
  1046. ;;; 
  1047. (defun parse-alien-record-fields (result fields)
  1048.   (declare (type alien-record-type result)
  1049.        (type list fields))
  1050.   (let ((total-bits 0)
  1051.     (overall-alignment 1)
  1052.     (parsed-fields nil))
  1053.     (dolist (field fields)
  1054.       (destructuring-bind (var type &optional bits) field
  1055.     (declare (ignore bits))
  1056.     (let* ((field-type (parse-alien-type type))
  1057.            (bits (alien-type-bits field-type))
  1058.            (alignment (alien-type-alignment field-type))
  1059.            (parsed-field
  1060.         (make-alien-record-field :type field-type
  1061.                      :name var)))
  1062.       (push parsed-field parsed-fields)
  1063.       (when (null bits)
  1064.         (error "Unknown size: ~S"
  1065.            (unparse-alien-type field-type)))
  1066.       (when (null alignment)
  1067.         (error "Unknown alignment: ~S"
  1068.            (unparse-alien-type field-type)))
  1069.       (setf overall-alignment (max overall-alignment alignment))
  1070.       (ecase (alien-record-type-kind result)
  1071.         (:struct
  1072.          (let ((offset (align-offset total-bits alignment)))
  1073.            (setf (alien-record-field-offset parsed-field) offset)
  1074.            (setf total-bits (+ offset bits))))
  1075.         (:union
  1076.          (setf total-bits (max total-bits bits)))))))
  1077.     (let ((new (nreverse parsed-fields)))
  1078.       (setf (alien-record-type-fields result) new))
  1079.     (setf (alien-record-type-alignment result) overall-alignment)
  1080.     (setf (alien-record-type-bits result)
  1081.       (align-offset total-bits overall-alignment))))
  1082.  
  1083. (def-alien-type-method (record :unparse) (type)
  1084.   `(,(case (alien-record-type-kind type)
  1085.        (:struct 'struct)
  1086.        (:union 'union)
  1087.        (t '???))
  1088.     ,(alien-record-type-name type)
  1089.     ,@(unless (member type *record-types-already-unparsed* :test #'eq)
  1090.     (push type *record-types-already-unparsed*)
  1091.     (mapcar #'(lambda (field)
  1092.             `(,(alien-record-field-name field)
  1093.               ,(%unparse-alien-type (alien-record-field-type field))
  1094.               ,@(if (alien-record-field-bits field)
  1095.                 (list (alien-record-field-bits field)))))
  1096.         (alien-record-type-fields type)))))
  1097.  
  1098. (defun record-fields-match (fields1 fields2)
  1099.   (declare (type list fields1 fields2))
  1100.   (or (eq fields1 fields2)
  1101.       (and fields1
  1102.        fields2
  1103.        (let ((field1 (car fields1))
  1104.          (field2 (car fields2)))
  1105.          (declare (type alien-record-field field1 field2))
  1106.          (and (eq (alien-record-field-name field1)
  1107.               (alien-record-field-name field2))
  1108.           (eql (alien-record-field-bits field1)
  1109.                (alien-record-field-bits field2))
  1110.           (eql (alien-record-field-offset field1)
  1111.                (alien-record-field-offset field2))
  1112.           (alien-type-= (alien-record-field-type field1)
  1113.                 (alien-record-field-type field2))))
  1114.        (record-fields-match (cdr fields1) (cdr fields2)))))
  1115.  
  1116. (def-alien-type-method (record :type=) (type1 type2)
  1117.   (and (eq (alien-record-type-name type1)
  1118.        (alien-record-type-name type2))
  1119.        (eq (alien-record-type-kind type1)
  1120.        (alien-record-type-kind type2))
  1121.        (= (length (alien-record-type-fields type1))
  1122.       (length (alien-record-type-fields type2)))
  1123.        (record-fields-match (alien-record-type-fields type1)
  1124.                 (alien-record-type-fields type2))))
  1125.  
  1126.  
  1127. ;;;; The FUNCTION and VALUES types.
  1128.  
  1129. (defvar *values-type-okay* nil)
  1130.  
  1131. (def-alien-type-class (function :include mem-block)
  1132.   (result-type (required-argument) :type alien-type)
  1133.   (arg-types (required-argument) :type list)
  1134.   (stub nil :type (or null function)))
  1135.  
  1136. (def-alien-type-translator function (result-type &rest arg-types)
  1137.   (make-alien-function-type
  1138.    :result-type (let ((*values-type-okay* t))
  1139.           (parse-alien-type result-type))
  1140.    :arg-types (mapcar #'parse-alien-type arg-types)))
  1141.  
  1142. (def-alien-type-method (function :unparse) (type)
  1143.   `(function ,(%unparse-alien-type (alien-function-type-result-type type))
  1144.          ,@(mapcar #'%unparse-alien-type
  1145.                (alien-function-type-arg-types type))))
  1146.  
  1147. (def-alien-type-method (function :type=) (type1 type2)
  1148.   (and (alien-type-= (alien-function-type-result-type type1)
  1149.              (alien-function-type-result-type type2))
  1150.        (= (length (alien-function-type-arg-types type1))
  1151.       (length (alien-function-type-arg-types type2)))
  1152.        (every #'alien-type-p
  1153.           (alien-function-type-arg-types type1)
  1154.           (alien-function-type-arg-types type2))))
  1155.  
  1156.  
  1157. (def-alien-type-class (values)
  1158.   (values (required-argument) :type list))
  1159.  
  1160. (def-alien-type-translator values (&rest values)
  1161.   (unless *values-type-okay*
  1162.     (error "Cannot use values types here."))
  1163.   (let ((*values-type-okay* nil))
  1164.     (make-alien-values-type
  1165.      :values (mapcar #'parse-alien-type values))))
  1166.  
  1167. (def-alien-type-method (values :unparse) (type)
  1168.   `(values ,@(mapcar #'%unparse-alien-type
  1169.              (alien-values-type-values type))))
  1170.  
  1171. (def-alien-type-method (values :type=) (type1 type2)
  1172.   (and (= (length (alien-values-type-values type1))
  1173.       (length (alien-values-type-values type2)))
  1174.        (every #'alien-type-=
  1175.           (alien-values-type-values type1)
  1176.           (alien-values-type-values type2))))
  1177.  
  1178.  
  1179.  
  1180. ;;;; Alien variables.
  1181.  
  1182. ;;; HEAP-ALIEN-INFO -- defstruct.
  1183. ;;;
  1184. ;;; Information describing a heap-allocated alien.
  1185. ;;; 
  1186. (defstruct (heap-alien-info
  1187.         (:print-function %print-heap-alien-info)
  1188.         (:make-load-form-fun :just-dump-it-normally))
  1189.   ;; The type of this alien.
  1190.   (type (required-argument) :type alien-type)
  1191.   ;; The form to evaluate to produce the SAP pointing to where in the heap
  1192.   ;; it is.
  1193.   (sap-form (required-argument)))
  1194. ;;;
  1195. (defun %print-heap-alien-info (info stream depth)
  1196.   (declare (ignore depth))
  1197.   (print-unreadable-object (info stream :type t)
  1198.     (funcall (formatter "~S ~S")
  1199.          stream
  1200.          (heap-alien-info-sap-form info)
  1201.          (unparse-alien-type (heap-alien-info-type info)))))
  1202.  
  1203. ;;; LOCAL-ALIEN-INFO -- public defstruct.
  1204. ;;;
  1205. ;;; Information about local aliens.  The WITH-ALIEN macro builds one of these
  1206. ;;; structures and local-alien and friends comunicate information about how
  1207. ;;; that local alien is represented.
  1208. ;;; 
  1209. (defstruct (local-alien-info
  1210.         (:print-function %print-local-alien-info)
  1211.         (:make-load-form-fun :just-dump-it-normally))
  1212.   ;; The type of the local alien.
  1213.   (type (required-argument) :type alien-type)
  1214.   ;; T if this local alien must be forced into memory.  Using the ADDR macro
  1215.   ;; on a local alien will set this.
  1216.   (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type))
  1217.              :type (member t nil)))
  1218. ;;;
  1219. (defun %print-local-alien-info (info stream depth)
  1220.   (declare (ignore depth))
  1221.   (print-unreadable-object (info stream :type t)
  1222.     (funcall (formatter "~:[~;(forced to stack) ~]~S")
  1223.          stream
  1224.          (local-alien-info-force-to-memory-p info)
  1225.          (unparse-alien-type (local-alien-info-type info)))))
  1226.  
  1227. ;;; GUESS-ALIEN-NAME-FROM-LISP-NAME -- internal.
  1228. ;;;
  1229. ;;; Make a string out of the symbol, converting all uppercase letters to
  1230. ;;; lower case and hyphens into underscores.
  1231. ;;; 
  1232. (defun guess-alien-name-from-lisp-name (lisp-name)
  1233.   (declare (type symbol lisp-name))
  1234.   (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name))))
  1235.  
  1236. ;;; GUESS-LISP-NAME-FROM-ALIEN-NAME -- internal.
  1237. ;;;
  1238. ;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME.  Make a symbol out of the
  1239. ;;; string, converting all lowercase letters to uppercase and underscores into
  1240. ;;; hyphens.
  1241. ;;;
  1242. (defun guess-lisp-name-from-alien-name (alien-name)
  1243.   (declare (type simple-string alien-name))
  1244.   (intern (nsubstitute #\- #\_ (string-upcase alien-name))))
  1245.  
  1246. ;;; PICK-LISP-AND-ALIEN-NAMES -- internal.
  1247. ;;;
  1248. ;;; Extract the lisp and alien names from NAME.  If only one is given, guess
  1249. ;;; the other.
  1250. ;;; 
  1251. (defun pick-lisp-and-alien-names (name)
  1252.   (etypecase name
  1253.     (string
  1254.      (values (guess-lisp-name-from-alien-name name) name))
  1255.     (symbol
  1256.      (values name (guess-alien-name-from-lisp-name name)))
  1257.     (list
  1258.      (unless (= (length name) 2)
  1259.        (error "Badly formed alien name."))
  1260.      (values (cadr name) (car name)))))
  1261.  
  1262. ;;; DEF-ALIEN-VARIABLE -- public
  1263. ;;;
  1264. (defmacro def-alien-variable (name type)
  1265.   "Define NAME as an external alien variable of type TYPE.  NAME should be
  1266.    a list of a symbol to use as the Lisp name, and a string holding the alien
  1267.    name.  If NAME is just a symbol or string, then the other name is guessed
  1268.    from the one supplied."
  1269.   (multiple-value-bind
  1270.       (lisp-name alien-name)
  1271.       (pick-lisp-and-alien-names name)
  1272.     (with-auxiliary-alien-types
  1273.       (let ((alien-type (parse-alien-type type)))
  1274.     `(eval-when (compile load eval)
  1275.        ,@(when *new-auxiliary-types*
  1276.            `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
  1277.        (%def-alien-variable ',lisp-name
  1278.                 ',alien-name
  1279.                 ',alien-type))))))
  1280.  
  1281. ;;; %DEF-ALIEN-VARIABLE -- internal
  1282. ;;;
  1283. ;;; Do the actual work of DEF-ALIEN-VARIABLE.
  1284. ;;; 
  1285. (defun %def-alien-variable (lisp-name alien-name type)
  1286.   (setf (info variable kind lisp-name) :alien)
  1287.   (setf (info variable where-from lisp-name) :defined)
  1288.   (clear-info variable constant-value lisp-name)
  1289.   (setf (info variable alien-info lisp-name)
  1290.     (make-heap-alien-info :type type
  1291.                   :sap-form `(foreign-symbol-address
  1292.                       ',alien-name))))
  1293.  
  1294. ;;; EXTERN-ALIEN -- public.
  1295. ;;; 
  1296. (defmacro extern-alien (name type)
  1297.   "Access the alien variable named NAME, assuming it is of type TYPE.  This
  1298.    is setfable."
  1299.   (let ((alien-name (etypecase name
  1300.               (symbol (guess-alien-name-from-lisp-name name))
  1301.               (string name))))
  1302.     `(%heap-alien ',(make-heap-alien-info
  1303.              :type (parse-alien-type type)
  1304.              :sap-form `(foreign-symbol-address ',alien-name)))))
  1305.  
  1306. ;;; WITH-ALIEN -- public.
  1307. ;;;
  1308. (defmacro with-alien (bindings &body body)
  1309.   "Establish some local alien variables.  Each BINDING is of the form:
  1310.      VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
  1311.    ALLOCATION should be one of:
  1312.      :LOCAL (the default)
  1313.        The alien is allocated on the stack, and has dynamic extent.
  1314.      :STATIC
  1315.        The alien is allocated on the heap, and has infinate extent.  The alien
  1316.        is allocated at load time, so the same piece of memory is used each time
  1317.        this form executes.
  1318.      :EXTERN
  1319.        No alien is allocated, but VAR is established as a local name for
  1320.        the external alien given by EXTERNAL-NAME."
  1321.   (with-auxiliary-alien-types
  1322.     (dolist (binding (reverse bindings))
  1323.       (destructuring-bind
  1324.       (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
  1325.       binding
  1326.     (let ((alien-type (parse-alien-type type)))
  1327.       (multiple-value-bind
  1328.           (allocation initial-value)
  1329.           (if opt2p
  1330.           (values opt1 opt2)
  1331.           (case opt1
  1332.             (:extern
  1333.              (values opt1 (guess-alien-name-from-lisp-name symbol)))
  1334.             (:static
  1335.              (values opt1 nil))
  1336.             (t
  1337.              (values :local opt1))))
  1338.         (setf body
  1339.           (ecase allocation
  1340.             #+nil
  1341.             (:static
  1342.              (let ((sap
  1343.                 (make-symbol (concatenate 'string "SAP-FOR-"
  1344.                               (symbol-name symbol)))))
  1345.                `((let ((,sap (load-time-value (%make-alien ...))))
  1346.                (declare (type system-area-pointer ,sap))
  1347.                (symbol-macrolet
  1348.                 ((,symbol (sap-alien ,sap ,type)))
  1349.                 ,@(when initial-value
  1350.                 `((setq ,symbol ,initial-value)))
  1351.                 ,@body)))))
  1352.             (:extern
  1353.              (let ((info (make-heap-alien-info
  1354.                   :type alien-type
  1355.                   :sap-form `(foreign-symbol-address
  1356.                           ',initial-value))))
  1357.                `((symbol-macrolet
  1358.               ((,symbol (%heap-alien ',info)))
  1359.               ,@body))))
  1360.             (:local
  1361.              (let ((var (gensym))
  1362.                (initval (if initial-value (gensym)))
  1363.                (info (make-local-alien-info
  1364.                   :type alien-type)))
  1365.                `((let ((,var (make-local-alien ',info))
  1366.                    ,@(when initial-value
  1367.                    `((,initval ,initial-value))))
  1368.                (note-local-alien-type ',info ,var)
  1369.                (multiple-value-prog1
  1370.                    (symbol-macrolet
  1371.                 ((,symbol (local-alien ',info ,var)))
  1372.                 ,@(when initial-value
  1373.                     `((setq ,symbol ,initval)))
  1374.                 ,@body)
  1375.                  (dispose-local-alien ',info ,var))))))))))))
  1376.     (verify-local-auxiliaries-okay)
  1377.     `(compiler-let (*auxiliary-type-definitions*
  1378.             ',(append *new-auxiliary-types*
  1379.                   *auxiliary-type-definitions*))
  1380.        ,@body)))
  1381.  
  1382.  
  1383. ;;;; Runtime C values that don't correspond directly to Lisp types.
  1384.  
  1385. ;;; ALIEN-VALUE
  1386. ;;; 
  1387. (defstruct (alien-value
  1388.         (:print-function %print-alien-value))
  1389.   (sap (required-argument) :type system-area-pointer)
  1390.   (type (required-argument) :type alien-type))
  1391. ;;;
  1392. (defun %print-alien-value (value stream depth)
  1393.   (declare (ignore depth))
  1394.   (print-unreadable-object (value stream)
  1395.     (funcall (formatter "Alien ~S at #x~8,'0X")
  1396.          stream 
  1397.          (unparse-alien-type (alien-value-type value))
  1398.          (sap-int (alien-value-sap value)))))
  1399.  
  1400. (declaim (freeze-type alien-value))
  1401.  
  1402. (declaim (inline null-alien))
  1403. (defun null-alien (x)
  1404.   "Return true if X (which must be an Alien pointer) is null, false otherwise."
  1405.   (zerop (sap-int (alien-sap x))))
  1406.  
  1407.   
  1408. (defmacro sap-alien (sap type)
  1409.   "Convert the System-Area-Pointer SAP to an Alien of the specified Type (not
  1410.    evaluated.)  Type must be pointer-like."
  1411.   (let ((alien-type (parse-alien-type type)))
  1412.     (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer)
  1413.     `(%sap-alien ,sap ',alien-type)
  1414.     (error "Cannot make aliens of type ~S out of SAPs" type))))
  1415.  
  1416. (defun %sap-alien (sap type)
  1417.   (declare (type system-area-pointer sap)
  1418.        (type alien-type type))
  1419.   (make-alien-value :sap sap :type type))
  1420.  
  1421. (defun alien-sap (alien)
  1422.   "Return a System-Area-Pointer pointing to Alien's data."
  1423.   (declare (type alien-value alien))
  1424.   (alien-value-sap alien))
  1425.  
  1426.  
  1427.  
  1428. ;;;; Allocation/Deallocation of heap aliens.
  1429.  
  1430. ;;; MAKE-ALIEN -- public.
  1431. ;;; 
  1432. (defmacro make-alien (type &optional size)
  1433.   "Allocate an alien of type TYPE and return an alien pointer to it.  If SIZE
  1434.    is supplied, how it is interpreted depends on TYPE.  If TYPE is an array
  1435.    type, SIZE is used as the first dimension for the allocated array.  If TYPE
  1436.    is not an array, then SIZE is the number of elements to allocate.  The
  1437.    memory is allocated using ``malloc'', so it can be passed to foreign
  1438.    functions which use ``free''."
  1439.   (let ((alien-type (if (alien-type-p type) type (parse-alien-type type))))
  1440.     (multiple-value-bind
  1441.     (size-expr element-type)
  1442.     (if (alien-array-type-p alien-type)
  1443.         (let ((dims (alien-array-type-dimensions alien-type)))
  1444.           (cond
  1445.            (size
  1446.         (unless dims
  1447.           (error
  1448.            "Cannot override the size of zero-dimensional arrays."))
  1449.         (when (constantp size)
  1450.           (setf alien-type (copy-alien-array-type alien-type))
  1451.           (setf (alien-array-type-dimensions alien-type)
  1452.             (cons (eval size) (cdr dims)))))
  1453.            (dims
  1454.         (setf size (car dims)))
  1455.            (t
  1456.         (setf size 1)))
  1457.           (values `(* ,size ,@(cdr dims))
  1458.               (alien-array-type-element-type alien-type)))
  1459.         (values (or size 1) alien-type))
  1460.       (let ((bits (alien-type-bits element-type))
  1461.         (alignment (alien-type-alignment element-type)))
  1462.     (unless bits
  1463.       (error "Size of ~S unknown." (unparse-alien-type element-type)))
  1464.     (unless alignment
  1465.       (error "Alignment of ~S unknown." (unparse-alien-type element-type)))
  1466.     `(%sap-alien (%make-alien (* ,(align-offset bits alignment)
  1467.                      ,size-expr))
  1468.              ',(make-alien-pointer-type :to alien-type))))))
  1469.  
  1470. ;;; %MAKE-ALIEN -- internal
  1471. ;;;
  1472. ;;; Allocate a block of memory at least BITS bits long and return a system
  1473. ;;; area pointer to it.
  1474. ;;;
  1475. (declaim (inline %make-alien))
  1476. (defun %make-alien (bits)
  1477.   (declare (type kernel:index bits) (optimize-interface (safety 2)))
  1478.   (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
  1479.          (ash (the kernel:index (+ bits 7)) -3)))
  1480.  
  1481. ;;; FREE-ALIEN -- public
  1482. ;;;
  1483. (declaim (inline free-alien))
  1484. (defun free-alien (alien)
  1485.   "Dispose of the storage pointed to by ALIEN.  ALIEN must have been allocated
  1486.    by MAKE-ALIEN or ``malloc''."
  1487.   (alien-funcall (extern-alien "free" (function (values) system-area-pointer))
  1488.          (alien-sap alien))
  1489.   nil)
  1490.  
  1491.  
  1492. ;;;; The SLOT operator
  1493.  
  1494. ;;; SLOT-OR-LOSE -- internal.
  1495. ;;;
  1496. ;;; Find the field named SLOT, or die trying.
  1497. ;;; 
  1498. (defun slot-or-lose (type slot)
  1499.   (declare (type alien-record-type type)
  1500.        (type symbol slot))
  1501.   (or (find slot (alien-record-type-fields type)
  1502.         :key #'alien-record-field-name)
  1503.       (error "No slot named ~S in ~S" slot type)))
  1504.  
  1505. ;;; SLOT -- public
  1506. ;;;
  1507. ;;; Extract the value from the named slot from the record alien.  If the
  1508. ;;; alien is actually a pointer, then deref it first.
  1509. ;;; 
  1510. (defun slot (alien slot)
  1511.   "Extract SLOT from the Alien STRUCT or UNION ALIEN.  May be set with SETF."
  1512.   (declare (type alien-value alien)
  1513.        (type symbol slot)
  1514.        (optimize (inhibit-warnings 3)))
  1515.   (let ((type (alien-value-type alien)))
  1516.     (etypecase type
  1517.       (alien-pointer-type
  1518.        (slot (deref alien) slot))
  1519.       (alien-record-type
  1520.        (let ((field (slot-or-lose type slot)))
  1521.      (extract-alien-value (alien-value-sap alien)
  1522.                   (alien-record-field-offset field)
  1523.                   (alien-record-field-type field)))))))
  1524.  
  1525. ;;; %SET-SLOT -- public setf method
  1526. ;;;
  1527. ;;; Deposite the value in the specified slot of the record alien.  If the
  1528. ;;; alien is really a pointer, deref it first.  The compiler uses this
  1529. ;;; when it can't figure out anything better.
  1530. ;;; 
  1531. (defun %set-slot (alien slot value)
  1532.   (declare (type alien-value alien)
  1533.        (type symbol slot)
  1534.        (optimize (inhibit-warnings 3)))
  1535.   (let ((type (alien-value-type alien)))
  1536.     (etypecase type
  1537.       (alien-pointer-type
  1538.        (%set-slot (deref alien) slot value))
  1539.       (alien-record-type
  1540.        (let ((field (slot-or-lose type slot)))
  1541.      (deposit-alien-value (alien-value-sap alien)
  1542.                   (alien-record-field-offset field)
  1543.                   (alien-record-field-type field)
  1544.                   value))))))
  1545. ;;;
  1546. (defsetf slot %set-slot)
  1547.  
  1548. ;;; %SLOT-ADDR -- internal
  1549. ;;; 
  1550. ;;; Compute the address of the specified slot and return a pointer to it.
  1551. ;;; 
  1552. (defun %slot-addr (alien slot)
  1553.   (declare (type alien-value alien)
  1554.        (type symbol slot)
  1555.        (optimize (inhibit-warnings 3)))
  1556.   (let ((type (alien-value-type alien)))
  1557.     (etypecase type
  1558.       (alien-pointer-type
  1559.        (%slot-addr (deref alien) slot))
  1560.       (alien-record-type
  1561.        (let* ((field (slot-or-lose type slot))
  1562.           (offset (alien-record-field-offset field))
  1563.           (field-type (alien-record-field-type field)))
  1564.      (%sap-alien (sap+ (alien-sap alien) (/ offset vm:byte-bits))
  1565.              (make-alien-pointer-type :to field-type)))))))
  1566.  
  1567.  
  1568. ;;;; The DEREF operator.
  1569.  
  1570. ;;; DEREF-GUTS -- internal.
  1571. ;;;
  1572. ;;; Does most of the work of the different DEREF methods.  Returns two values:
  1573. ;;; the type and the offset (in bits) of the refered to alien.
  1574. ;;; 
  1575. (defun deref-guts (alien indices)
  1576.   (declare (type alien-value alien)
  1577.        (type list indices)
  1578.        (values alien-type integer))
  1579.   (let ((type (alien-value-type alien)))
  1580.     (etypecase type
  1581.       (alien-pointer-type
  1582.        (when (cdr indices)
  1583.      (error "Too many indices when derefing ~S: ~D"
  1584.         type
  1585.         (length indices)))
  1586.        (let ((element-type (alien-pointer-type-to type)))
  1587.      (values element-type
  1588.          (if indices
  1589.              (* (align-offset (alien-type-bits element-type)
  1590.                       (alien-type-alignment element-type))
  1591.             (car indices))
  1592.              0))))
  1593.       (alien-array-type
  1594.        (unless (= (length indices) (length (alien-array-type-dimensions type)))
  1595.      (error "Incorrect number of indices when derefing ~S: ~D"
  1596.         type (length indices)))
  1597.        (labels ((frob (dims indices offset)
  1598.           (if (null dims)
  1599.               offset
  1600.               (frob (cdr dims) (cdr indices)
  1601.             (+ (if (zerop offset)
  1602.                    0
  1603.                    (* offset (car dims)))
  1604.                (car indices))))))
  1605.      (let ((element-type (alien-array-type-element-type type)))
  1606.        (values element-type
  1607.            (* (align-offset (alien-type-bits element-type)
  1608.                     (alien-type-alignment element-type))
  1609.               (frob (alien-array-type-dimensions type)
  1610.             indices 0)))))))))
  1611.  
  1612. ;;; DEREF -- public
  1613. ;;;
  1614. ;;; Dereference the alien and return the results.
  1615. ;;; 
  1616. (defun deref (alien &rest indices)
  1617.   "De-reference an Alien pointer or array.  If an array, the indices are used
  1618.    as the indices of the array element to access.  If a pointer, one index can
  1619.    optionally be specified, giving the equivalent of C pointer arithmetic."
  1620.   (declare (type alien-value alien)
  1621.        (type list indices)
  1622.        (optimize (inhibit-warnings 3)))
  1623.   (multiple-value-bind
  1624.       (target-type offset)
  1625.       (deref-guts alien indices)
  1626.     (extract-alien-value (alien-value-sap alien)
  1627.              offset
  1628.              target-type)))
  1629.  
  1630. ;;; %SET-DEREF -- public setf method
  1631. ;;; 
  1632. (defun %set-deref (alien value &rest indices)
  1633.   (declare (type alien-value alien)
  1634.        (type list indices)
  1635.        (optimize (inhibit-warnings 3)))
  1636.   (multiple-value-bind
  1637.       (target-type offset)
  1638.       (deref-guts alien indices)
  1639.     (deposit-alien-value (alien-value-sap alien)
  1640.              offset
  1641.              target-type
  1642.              value)))
  1643. ;;;
  1644. (defsetf deref (alien &rest indices) (value)
  1645.   `(%set-deref ,alien ,value ,@indices))
  1646.  
  1647. ;;; %DEREF-ADDR -- public
  1648. ;;;
  1649. (defun %deref-addr (alien &rest indices)
  1650.   (declare (type alien-value alien)
  1651.        (type list indices)
  1652.        (optimize (inhibit-warnings 3)))
  1653.   (multiple-value-bind
  1654.       (target-type offset)
  1655.       (deref-guts alien indices)
  1656.     (%sap-alien (sap+ (alien-value-sap alien) (/ offset vm:byte-bits))
  1657.         (make-alien-pointer-type :to target-type))))
  1658.  
  1659.  
  1660. ;;;; Accessing heap alien variables.
  1661.  
  1662. (defun %heap-alien (info)
  1663.   (declare (type heap-alien-info info)
  1664.        (optimize (inhibit-warnings 3)))
  1665.   (extract-alien-value (eval (heap-alien-info-sap-form info))
  1666.                0
  1667.                (heap-alien-info-type info)))
  1668.  
  1669. (defun %set-heap-alien (info value)
  1670.   (declare (type heap-alien-info info)
  1671.        (optimize (inhibit-warnings 3)))
  1672.   (deposit-alien-value (eval (heap-alien-info-sap-form info))
  1673.                0
  1674.                (heap-alien-info-type info)
  1675.                value))
  1676. ;;;
  1677. (defsetf %heap-alien %set-heap-alien)
  1678.  
  1679. (defun %heap-alien-addr (info)
  1680.   (declare (type heap-alien-info info)
  1681.        (optimize (inhibit-warnings 3)))
  1682.   (%sap-alien (eval (heap-alien-info-sap-form info))
  1683.           (make-alien-pointer-type :to (heap-alien-info-type info))))
  1684.  
  1685.  
  1686.  
  1687. ;;;; Accessing local aliens.
  1688.  
  1689. (defun make-local-alien (info)
  1690.   (let ((alien (eval `(make-alien ,(local-alien-info-type info)))))
  1691.     (finalize info #'(lambda () (free-alien alien)))
  1692.     alien))
  1693.  
  1694. (defun note-local-alien-type (info alien)
  1695.   (declare (ignore info alien))
  1696.   nil)
  1697.  
  1698. (defun local-alien (info alien)
  1699.   (declare (ignore info))
  1700.   (deref alien))
  1701.  
  1702. (defun %set-local-alien (info alien value)
  1703.   (declare (ignore info))
  1704.   (setf (deref alien) value))
  1705.  
  1706. (define-setf-method local-alien (&whole whole info alien)
  1707.   (let ((value (gensym))
  1708.     (info (if (and (consp info)
  1709.                (eq (car info) 'quote))
  1710.           (second info)
  1711.           (error "Something is wrong; local-alien-info not found: ~S"
  1712.              whole))))
  1713.     (values nil
  1714.         nil
  1715.         (list value)
  1716.         (if c:*converting-for-interpreter*
  1717.         `(%set-local-alien ',info ,alien ,value)
  1718.         `(if (%local-alien-forced-to-memory-p ',info)
  1719.              (%set-local-alien ',info ,alien ,value)
  1720.              (setf ,alien
  1721.                (deport ,value ',(local-alien-info-type info)))))
  1722.         whole)))
  1723.  
  1724. (defun %local-alien-forced-to-memory-p (info)
  1725.   (local-alien-info-force-to-memory-p info))
  1726.  
  1727. (defun %local-alien-addr (info alien)
  1728.   (declare (type local-alien-info info))
  1729.   (unless (local-alien-info-force-to-memory-p info)
  1730.     (error "~S isn't forced to memory.  Something went wrong." alien))
  1731.   alien)
  1732.  
  1733. (defun dispose-local-alien (info alien)
  1734.   (declare (ignore info))
  1735.   #+nil
  1736.   (cancel-finalization info)
  1737.   (free-alien alien))
  1738.  
  1739.  
  1740. ;;;; The ADDR macro.
  1741.  
  1742. (defmacro addr (expr &environment env)
  1743.   "Return an Alien pointer to the data addressed by Expr, which must be a call
  1744.    to SLOT or DEREF, or a reference to an Alien variable."
  1745.   (let ((form (macroexpand expr env)))
  1746.     (or (typecase form
  1747.       (cons
  1748.        (case (car form)
  1749.          (slot
  1750.           (cons '%slot-addr (cdr form)))
  1751.          (deref
  1752.           (cons '%deref-addr (cdr form)))
  1753.          (%heap-alien
  1754.           (cons '%heap-alien-addr (cdr form)))
  1755.          (local-alien
  1756.           (let ((info
  1757.              (let ((info-arg (second form)))
  1758.                (and (consp info-arg)
  1759.                 (eq (car info-arg) 'quote)
  1760.                 (second info-arg)))))
  1761.         (unless (local-alien-info-p info)
  1762.           (error "Something is wrong, local-alien-info not found: ~S"
  1763.              form))
  1764.         (setf (local-alien-info-force-to-memory-p info) t))
  1765.           (cons '%local-alien-addr (cdr form)))))
  1766.       (symbol
  1767.        (let ((kind (info variable kind form)))
  1768.          (when (eq kind :alien)
  1769.            `(%heap-alien-addr ',(info variable alien-info form))))))
  1770.     (error "~S is not a valid L-value" form))))
  1771.  
  1772.  
  1773. ;;;; The CAST macro.
  1774.  
  1775. (defmacro cast (alien type)
  1776.   "Convert ALIEN to an Alien of the specified TYPE (not evaluated.)  Both types
  1777.    must be Alien array, pointer or function types."
  1778.   `(%cast ,alien ',(parse-alien-type type)))
  1779.  
  1780. (defun %cast (alien target-type)
  1781.   (declare (type alien-value alien)
  1782.        (type alien-type target-type)
  1783.        (optimize-interface (safety 2))
  1784.        (optimize (inhibit-warnings 3)))
  1785.   (if (or (alien-pointer-type-p target-type)
  1786.       (alien-array-type-p target-type)
  1787.       (alien-function-type-p target-type))
  1788.       (let ((alien-type (alien-value-type alien)))
  1789.     (if (or (alien-pointer-type-p alien-type)
  1790.         (alien-array-type-p alien-type)
  1791.         (alien-function-type-p alien-type))
  1792.         (naturalize (alien-value-sap alien) target-type)
  1793.         (error "~S cannot be casted." alien)))
  1794.       (error "Cannot cast to alien type ~S" (unparse-alien-type target-type))))
  1795.  
  1796.  
  1797.  
  1798. ;;;; The ALIEN-SIZE macro.
  1799.  
  1800. (defmacro alien-size (type &optional (units :bits))
  1801.   "Return the size of the alien type TYPE.  UNITS specifies the units to
  1802.    use and can be either :BITS, :BYTES, or :WORDS."
  1803.   (let* ((alien-type (parse-alien-type type))
  1804.      (bits (alien-type-bits alien-type)))
  1805.     (if bits
  1806.     (values (ceiling bits
  1807.              (ecase units
  1808.                (:bits 1)
  1809.                (:bytes vm:byte-bits)
  1810.                (:words vm:word-bits))))
  1811.     (error "Unknown size for alien type ~S."
  1812.            (unparse-alien-type alien-type)))))
  1813.  
  1814.  
  1815.  
  1816. ;;;; Naturalize, deport, extract-alien-value, deposit-alien-value
  1817.  
  1818. (defun naturalize (alien type)
  1819.   (declare (type alien-type type))
  1820.   (funcall (coerce (compute-naturalize-lambda type) 'function)
  1821.        alien type))
  1822.  
  1823. (defun deport (value type)
  1824.   (declare (type alien-type type))
  1825.   (funcall (coerce (compute-deport-lambda type) 'function)
  1826.        value type))
  1827.  
  1828. (defun extract-alien-value (sap offset type)
  1829.   (declare (type system-area-pointer sap)
  1830.        (type unsigned-byte offset)
  1831.        (type alien-type type))
  1832.   (funcall (coerce (compute-extract-lambda type) 'function)
  1833.        sap offset type))
  1834.  
  1835. (defun deposit-alien-value (sap offset type value)
  1836.   (declare (type system-area-pointer sap)
  1837.        (type unsigned-byte offset)
  1838.        (type alien-type type))
  1839.   (funcall (coerce (compute-deposit-lambda type) 'function)
  1840.        sap offset type value))
  1841.  
  1842.  
  1843.  
  1844. ;;;; alien-funcall, def-alien-function
  1845.  
  1846. (defun alien-funcall (alien &rest args)
  1847.   "Call the foreign function ALIEN with the specified arguments.  ALIEN's
  1848.    type specifies the argument and result types."
  1849.   (declare (type alien-value alien))
  1850.   (let ((type (alien-value-type alien)))
  1851.     (typecase type
  1852.       (alien-pointer-type
  1853.        (apply #'alien-funcall (deref alien) args))
  1854.       (alien-function-type
  1855.        (unless (= (length (alien-function-type-arg-types type))
  1856.           (length args))
  1857.      (error "Wrong number of arguments for ~S~%Expected ~D, got ~D."
  1858.         type
  1859.         (length (alien-function-type-arg-types type))
  1860.         (length args)))
  1861.        (let ((stub (alien-function-type-stub type)))
  1862.      (unless stub
  1863.        (setf stub
  1864.          (let ((fun (gensym))
  1865.                (parms (loop repeat (length args) collect (gensym))))
  1866.            (compile nil
  1867.                 `(lambda (,fun ,@parms)
  1868.                    (declare (type (alien ,type) ,fun))
  1869.                    (alien-funcall ,fun ,@parms)))))
  1870.        (setf (alien-function-type-stub type) stub))
  1871.      (apply stub alien args)))
  1872.       (t
  1873.        (error "~S is not an alien function." alien)))))
  1874.  
  1875. (defmacro def-alien-routine (name result-type &rest args)
  1876.   "Def-C-Routine Name Result-Type
  1877.                     {(Arg-Name Arg-Type [Style])}*
  1878.  
  1879.   Define a foreign interface function for the routine with the specified Name,
  1880.   which may be either a string, symbol or list of the form (symbol string).
  1881.   Return-Type is the Alien fypte for the function return value.  VOID may be
  1882.   used to specify a function with no result.
  1883.  
  1884.   The remaining forms specifiy individual arguments that are passed to the
  1885.   routine.  Arg-Name is a symbol that names the argument, primarily for
  1886.   documentation.  Arg-Type is the C-Type of the argument.  Style specifies the
  1887.   say that the argument is passed.
  1888.  
  1889.   :IN
  1890.         An :In argument is simply passed by value.  The value to be passed is
  1891.         obtained from argument(s) to the interface function.  No values are
  1892.         returned for :In arguments.  This is the default mode.
  1893.  
  1894.   :OUT
  1895.         The specified argument type must be a pointer to a fixed sized object.
  1896.         A pointer to a preallocated object is passed to the routine, and the
  1897.         the object is accessed on return, with the value being returned from
  1898.         the interface function.  :OUT and :IN-OUT cannot be used with pointers
  1899.         to arrays, records or functions.
  1900.  
  1901.   :COPY
  1902.         Similar to :IN, except that the argument values are stored in on
  1903.         the stack, and a pointer to the object is passed instead of
  1904.         the values themselves.
  1905.  
  1906.   :IN-OUT
  1907.         A combination of :OUT and :COPY.  A pointer to the argument is passed,
  1908.         with the object being initialized from the supplied argument and
  1909.         the return value being determined by accessing the object on return."
  1910.   (multiple-value-bind
  1911.       (lisp-name alien-name)
  1912.       (pick-lisp-and-alien-names name)
  1913.     (collect ((docs) (lisp-args) (arg-types) (alien-vars)
  1914.           (alien-args) (results))
  1915.       (dolist (arg args)
  1916.     (if (stringp arg)
  1917.         (docs arg)
  1918.         (destructuring-bind (name type &optional (style :in)) arg
  1919.           (unless (member style '(:in :copy :out :in-out))
  1920.         (error "Bogus argument style ~S in ~S." style arg))
  1921.           (unless (eq style :out)
  1922.         (lisp-args name))
  1923.           (cond ((eq style :in)
  1924.              (arg-types type)
  1925.              (alien-args name))
  1926.             (t
  1927.              (arg-types `(* ,type))
  1928.              (if (eq style :out)
  1929.              (alien-vars `(,name ,type))
  1930.              (alien-vars `(,name ,type ,name)))
  1931.              (alien-args `(addr ,name))))
  1932.           (when (or (eq style :out) (eq style :in-out))
  1933.         (results name)))))
  1934.       `(defun ,lisp-name ,(lisp-args)
  1935.      ,@(docs)
  1936.      (with-alien
  1937.          ((,lisp-name (function ,result-type ,@(arg-types))
  1938.               :extern ,alien-name)
  1939.           ,@(alien-vars))
  1940.          ,(if (alien-values-type-p result-type)
  1941.           (let ((temps (loop
  1942.                  repeat (length (alien-values-type-values
  1943.                          result-type))
  1944.                  collect (gensym))))
  1945.             `(multiple-value-bind
  1946.              ,temps
  1947.              (alien-funcall ,lisp-name ,@(alien-args))
  1948.                (values ,@temps ,@(results))))
  1949.           `(values (alien-funcall ,lisp-name ,@(alien-args))
  1950.                ,@(results))))))))
  1951.